home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / FORTRAN / 3017.ZIP / SOUND.FOR < prev    next >
Text File  |  1988-10-30  |  2KB  |  85 lines
  1.       PROGRAM SOUND
  2. C
  3. C     SOUND CAPABILITIES
  4. C     OLYMPIC SOFTWARE  9/27/88
  5. C
  6.       EXTERNAL INPUT,OUTPUT,SLOGIC
  7.       INTEGER*2 NTON,IFR(5),ICNT(5),IOP
  8.       INTEGER*2 IF0,IAL,IAL1,IAL2,IAL3,IDX,IT,IT1,I
  9. C
  10.       DATA NTON /5/
  11.       DATA IFR(1),IFR(2),IFR(3),IFR(4),IFR(5) /100,300,500,700,900/
  12.       DATA ICNT(1),ICNT(2),ICNT(3),ICNT(4),ICNT(5) /18,18,18,18,18/
  13. C
  14. C***   IFR CONTAINS FREQUENCIES IN HERTZ
  15. C***   ICNT CONTAINS DURATION TIMES IN 1/18 SECONDS
  16. C
  17.       IT=3
  18.       IT1=252
  19. C
  20. C**     GET TIMER READY
  21.       IDX=67
  22.       IAL=182
  23.       CALL OUTPUT(IAL,IDX)
  24. C
  25. C**     TURN SPEAKER ON
  26.       IDX=97
  27.       CALL INPUT(IAL1,IDX)
  28.       IDX=97
  29.       IOP=2
  30.       CALL SLOGIC(IOP,IAL,IAL1,IT)
  31.       CALL OUTPUT(IAL,IDX)
  32. C
  33.       DO 10 I=1,NTON
  34. C**     LOAD FREQUENCY COUNT
  35.       IF0=1.19318E+06/IFR(I)
  36.       IAL2=IF0-INT(IF0/256)*256
  37.       IAL3=IF0/256
  38.       IDX=66
  39.       CALL OUTPUT(IAL2,IDX)
  40.       IDX=66
  41.       CALL OUTPUT(IAL3,IDX)
  42. C
  43. C**     CALL TIMER
  44.       CALL STIMER(ICNT(I))
  45. C
  46.  10   CONTINUE
  47. C
  48. C**     TURN SPEAKER OFF
  49.       IDX=97
  50.       CALL INPUT(IAL1,IDX)
  51.       IOP=1
  52.       CALL SLOGIC(IOP,IAL,IAL1,IT1)
  53.       IDX=97
  54.       CALL OUTPUT(IAL,IDX)
  55. C
  56.       STOP
  57.       END
  58. C
  59.       SUBROUTINE STIMER(ICNT)
  60. C
  61. C     SHORT INTERVAL TIMER ROUTINE
  62. C     PROGRAM ENDS AFTER ICNT COUNTS (TOTAL DELAY <1 HOUR)
  63. C     INTERVAL : 1/18 SEC
  64. C     MIDNIGHT CROSSING RESETS STIMER (STIMER RETURNS)
  65. C     OLYMPIC SOFTWARE  --  9/26/88
  66. C
  67.       EXTERNAL TBIOS
  68.       INTEGER*2 IAR(6),ICNT
  69.       INTEGER*4 ICX,IDX,EC
  70. C
  71.       IAR(1)=0
  72.       CALL TBIOS(IAR)
  73.       IDX=IAR(5)*256+IAR(6)
  74.       IAR(1)=0
  75.  100  CALL TBIOS(IAR)
  76.       EC=IAR(5)*256+IAR(6)-IDX
  77.       IF(EC.LT.0)EC=EC+4*16384
  78.       IF(IAR(2).NE.0)GOTO 200
  79.       IF(EC.LT.ICNT)GOTO 100
  80. C
  81.  200  RETURN
  82.       END
  83.  
  84.  
  85.